Context
This is a historical dataset on the modern Olympic Games, including all the Games from Athens 1896 to Rio 2016. I scraped this data from www.sports-reference.com in May 2018. The R code I used to scrape and wrangle the data is on GitHub. I recommend checking my kernel before starting your own analysis.
Note that the Winter and Summer Games were held in the same year up until 1992. After that, they staggered them such that Winter Games occur on a four year cycle starting with 1994, then Summer in 1996, then Winter in 1998, and so on. A common mistake people make when analyzing this data is to assume that the Summer and Winter Games have always been staggered.
Content
The file athlete_events.csv contains 271116 rows and 15 columns. Each row corresponds to an individual athlete competing in an individual Olympic event (athlete-events). The columns are:
Acknowledgements
The Olympic data on www.sports-reference.com is the result of an incredible amount of research by a group of Olympic history enthusiasts and self-proclaimed ‘statistorians’. Check out their blog for more information. All I did was consolidated their decades of work into a convenient format for data analysis. Inspiration
This dataset provides an opportunity to ask questions about how the Olympics have evolved over time, including questions about the participation and performance of women, different nations, and different sports and events.
library(dplyr)
library(tidyr)
library(ggplot2)
library(knitr)
library(kableExtra) # do tabel w stylu bootstrap 5
d1 <- read.csv('athlete_events.csv')
dim(d1)
[1] 271116 15
head(d1[1:3,1:7])
| ID | Name | Sex | Age | Height | Weight | Team |
|---|---|---|---|---|---|---|
| 1 | A Dijiang | M | 24 | 180 | 80 | China |
| 2 | A Lamusi | M | 23 | 170 | 60 | China |
| 3 | Gunnar Nielsen Aaby | M | 24 | NA | NA | Denmark |
head(d1[1:3,8:15])
| NOC | Games | Year | Season | City | Sport | Event | Medal |
|---|---|---|---|---|---|---|---|
| CHN | 1992 Summer | 1992 | Summer | Barcelona | Basketball | Basketball Men’s Basketball | NA |
| CHN | 2012 Summer | 2012 | Summer | London | Judo | Judo Men’s Extra-Lightweight | NA |
| DEN | 1920 Summer | 1920 | Summer | Antwerpen | Football | Football Men’s Football | NA |
options(width = 150)
quantitive_cols <- c("ID", "Age", "Height", "Weight", "Year")
summary(d1[quantitive_cols])
ID Age Height Weight Year
Min. : 1 Min. :10.00 Min. :127.0 Min. : 25.0 Min. :1896
1st Qu.: 34643 1st Qu.:21.00 1st Qu.:168.0 1st Qu.: 60.0 1st Qu.:1960
Median : 68205 Median :24.00 Median :175.0 Median : 70.0 Median :1988
Mean : 68249 Mean :25.56 Mean :175.3 Mean : 70.7 Mean :1978
3rd Qu.:102097 3rd Qu.:28.00 3rd Qu.:183.0 3rd Qu.: 79.0 3rd Qu.:2002
Max. :135571 Max. :97.00 Max. :226.0 Max. :214.0 Max. :2016
NA's :9474 NA's :60171 NA's :62875
# names(d1)
categorical_cols <- setdiff(names(d1), quantitive_cols)
categorical_cols
[1] "Name" "Sex" "Team" "NOC" "Games" "Season" "City" "Sport" "Event" "Medal"
categ_df_list <- list()
for(i in categorical_cols) {
count <- length(na.omit(d1[[i]]))
unique <- length(unique(na.omit(d1[[i]])))
nan_perc <- sum(is.na(d1[[i]]))
top_three_sorted <- sort(table(d1[[i]]), decreasing = TRUE)[1:3]
top_three_names <- names(top_three_sorted)
top_three_counts <- as.vector(top_three_sorted)
names <- c('category', "Count", "Unique", "% NA", top_three_names[1], top_three_names[2], top_three_names[3])
values <- c(i, count, unique, as.character(round(nan_perc / 271116, 2)), top_three_counts[1], top_three_counts[2], top_three_counts[3])
categ_df <- setNames(as.data.frame(t(values)), names)
categ_df_list[[i]] <- categ_df
}
names <- rep('|', 7)
values <- rep(' ', 7)
empty_df <- t(setNames(as.data.frame(t(values)), names))
# kod tylko dla pierwszego wiersza
knitr::kable(
list(t(categ_df_list[[1]]), empty_df, t(categ_df_list[[2]]), empty_df, t(categ_df_list[[3]]), empty_df, t(categ_df_list[[4]])),
caption = 'Widok na kolumny kategoryczne z trzema najczęściej występującymi wartościami',
booktabs = TRUE, valign = 't'
)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
Rzeczywiście brakujące dane występują tylko w kolumnach wieku, wzrostu i wagi. Z oczywistych powodów brakujące dane w kontekście medali nie oznaczają nieistniejących danych, tylko nie zajęcie miejsca na podium. Jednak ciekawym aspektem medali jest ich nierówna ilość. Przyczynami mogą być:
# rozmiary czcionek
s <- 10
m <- 12
l <- 15
games_count <- d1 %>%
group_by(Games, Year, Season) %>%
summarise(Count = n()) %>%
arrange(desc(Count)) %>%
ungroup()
`summarise()` has grouped output by 'Games', 'Year'. You can override using the `.groups` argument.
games_count
# A tibble: 51 × 4
Games Year Season Count
<chr> <int> <chr> <int>
1 2000 Summer 2000 Summer 13821
2 1996 Summer 1996 Summer 13780
3 2016 Summer 2016 Summer 13688
4 2008 Summer 2008 Summer 13602
5 2004 Summer 2004 Summer 13443
6 1992 Summer 1992 Summer 12977
7 2012 Summer 2012 Summer 12920
8 1988 Summer 1988 Summer 12037
9 1972 Summer 1972 Summer 10304
10 1984 Summer 1984 Summer 9454
# ℹ 41 more rows
# sortowanie po latach
games_count$Games <- factor(games_count$Games, levels = games_count$Games[order(games_count$Year)])
d <- ggplot(games_count, aes(x = Games, y = Count, fill = Games)) +
geom_bar(stat = "identity") +
labs(x = "Games", y = "Count", title = "Count of Games by Year") +
theme_minimal() + theme_light() +
theme_minimal() + theme_light() +
geom_bar(stat = "identity") +
theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(y = "Ilość zawodników", x = "Rok i sezon igrzysk", title = "Ilość zawodników w Igrzyskach Olimpijskich") +
theme(text = element_text(family = "Courier New")) +
theme(axis.title.x = element_text(size=m),
axis.title.y = element_text(size=m),
axis.text.x = element_text(size=s),
axis.text.y = element_text(size=s),
plot.title = element_text(colour="Black", size=l, family="Courier New")) +
theme(legend.position = "none") +
scale_y_continuous(breaks = seq(0, max(games_count$Count), by = 1000)) # Ilość linii pomocniczych na Y
# d
d1_noNA <- d1[!(is.na(d1$Medal)), ]
medal_counts <- d1_noNA %>%
group_by(NOC, Medal) %>%
summarise(Count = n()) %>%
ungroup()
`summarise()` has grouped output by 'NOC'. You can override using the `.groups` argument.
medal_counts
# A tibble: 362 × 3
NOC Medal Count
<chr> <chr> <int>
1 AFG Bronze 2
2 AHO Silver 1
3 ALG Bronze 8
4 ALG Gold 5
5 ALG Silver 4
6 ANZ Bronze 5
7 ANZ Gold 20
8 ANZ Silver 4
9 ARG Bronze 91
10 ARG Gold 91
# ℹ 352 more rows
medal_counts <- medal_counts[order(medal_counts$Count, decreasing=TRUE), ]
medal_counts_p <- medal_counts %>%
pivot_wider(
names_from=Medal,
values_from=Count
)
medal_counts_p$Total <- medal_counts_p$Gold + medal_counts_p$Silver + medal_counts_p$Bronze
medal_counts_p <- medal_counts_p[order(medal_counts_p$Total, decreasing=T),]
head(medal_counts_p, 3)
# A tibble: 3 × 5
NOC Gold Silver Bronze Total
<chr> <int> <int> <int> <int>
1 USA 2638 1641 1358 5637
2 URS 1082 732 689 2503
3 GER 745 674 746 2165
dim(medal_counts_p)
[1] 149 5
top_countries <- medal_counts_p %>%
arrange(desc(Total)) %>%
head(25) %>%
pull(NOC)
top_countries
[1] "USA" "URS" "GER" "GBR" "FRA" "ITA" "SWE" "CAN" "AUS" "RUS" "HUN" "NED" "NOR" "GDR" "CHN" "JPN" "FIN" "SUI" "ROU" "KOR" "DEN" "FRG" "POL" "ESP"
[25] "TCH"
top_medal_counts <- medal_counts %>%
filter(NOC %in% top_countries)
head(top_medal_counts)
# A tibble: 6 × 3
NOC Medal Count
<chr> <chr> <int>
1 USA Gold 2638
2 USA Silver 1641
3 USA Bronze 1358
4 URS Gold 1082
5 GER Bronze 746
6 GER Gold 745
# Poprawienie sortowania państw
top_medal_counts$NOC <- factor(top_medal_counts$NOC, levels = top_countries)
head(top_medal_counts)
# A tibble: 6 × 3
NOC Medal Count
<fct> <chr> <int>
1 USA Gold 2638
2 USA Silver 1641
3 USA Bronze 1358
4 URS Gold 1082
5 GER Bronze 746
6 GER Gold 745
# Sortowanie bloków na słupkach - brąz, srebro, złoto
top_medal_counts$Medal <- factor(top_medal_counts$Medal, levels = c("Bronze", "Silver", "Gold"))
top_medal_counts
# A tibble: 75 × 3
NOC Medal Count
<fct> <fct> <int>
1 USA Gold 2638
2 USA Silver 1641
3 USA Bronze 1358
4 URS Gold 1082
5 GER Bronze 746
6 GER Gold 745
7 GBR Silver 739
8 URS Silver 732
9 URS Bronze 689
10 GBR Gold 678
# ℹ 65 more rows
medale_kolor <- c("Bronze"="#9D755d", "Silver"="#E2E2E2", "Gold"="#FECB52")
medale_nazwy <- c("Bronze"="Brąz", "Silver"="Srebro", "Gold"="Złoto")
e <- ggplot(top_medal_counts, aes(fill = Medal, y = Count, x = NOC)) +
theme_minimal() + theme_light() +
geom_bar(stat = "identity") +
theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
labs(fill = "Medal:", y = "Ilość medali", x = "Kraj", title = "Top 25 Państw w olimpiadach") +
theme(text = element_text(family = "Courier New")) +
theme(axis.title.x = element_text(size=m),
axis.title.y = element_text(size=m),
axis.text.x = element_text(size=s),
axis.text.y = element_text(size=s),
legend.title = element_text(size=s),
legend.text = element_text(size=s),
legend.justification = c(0,0.5),
plot.title = element_text(colour="Black", size=l, family="Courier New")) +
scale_fill_manual(values=medale_kolor, labels=medale_nazwy)
Zestaw danych zawiera nieistniejące już kraje, takie jak Związek Radziecki czy Jugosławia.
NOC_count <- d1 %>%
group_by(NOC) %>%
summarise(Count = n())
head(NOC_count)
# A tibble: 6 × 2
NOC Count
<chr> <int>
1 AFG 126
2 AHO 79
3 ALB 70
4 ALG 551
5 AND 169
6 ANG 267
medal_counts_p_ratio <- inner_join(medal_counts_p, NOC_count, by = "NOC")
medal_counts_p_ratio$Ratio <- round(medal_counts_p_ratio$Total / medal_counts_p_ratio$Count, 2)
medal_counts_p_ratio <- medal_counts_p_ratio[order(medal_counts_p_ratio$Ratio, decreasing=TRUE), ]
medal_counts_p_ratio <- head(medal_counts_p_ratio, 25)
head(medal_counts_p_ratio)
# A tibble: 6 × 7
NOC Gold Silver Bronze Total Count Ratio
<chr> <int> <int> <int> <int> <int> <dbl>
1 URS 1082 732 689 2503 5685 0.44
2 GDR 397 327 281 1005 2645 0.38
3 ANZ 20 4 5 29 86 0.34
4 EUN 127 71 81 279 864 0.32
5 USA 2638 1641 1358 5637 18853 0.3
6 RUS 390 367 408 1165 5143 0.23
write.csv(medal_counts_p_ratio, "medal_counts_p_ratio.csv")
medal_counts_p_ratio <- medal_counts_p_ratio %>% arrange(desc(medal_counts_p_ratio)) # sortowanie
max_total <- max(medal_counts_p_ratio$Total) # maksymalna wartość do limitu
f <- ggplot(medal_counts_p_ratio, aes(x = reorder(NOC, -Ratio))) +
geom_bar(aes(y = Total), stat = "identity", fill = "#00CC96") +
geom_line(aes(y = Ratio * max_total, group = 1), color = "#EF553B", size = 0.7) +
geom_text(aes(y = Ratio * max_total, label = Ratio),
vjust = -1.1, color = "black", size=2.3, family="Courier New", fontface="bold") +
scale_y_continuous( # do ustawienia 1.0 na prawej Y do max lewej Y
name = "Ilośc medali",
sec.axis = sec_axis(~ . / max_total, name = "Stosunek zdobytych medali do ilości zawodników")
) +
labs(x="Kraj", title = "Ilość zdobytych medali i stosuenk do ilości zawodników") +
theme_minimal() + theme_light() +
theme(
text = element_text(family = "Courier New"),
axis.title.x = element_text(size=m),
axis.title.y = element_text(size=m),
axis.title.y.right = element_text(color = "#873021"),
axis.text.y.right = element_text(size=s, color = "#873021"),
plot.title = element_text(colour="Black", size=l, family="Courier New")
)
#f
Mniej oczywiste kody państw
/ reprezentacji:
GDR - NRDANZ - Australazja
- Australia i Nowa ZeladniaEUN - Unified
Team - reprezentacja byłych krajów ze Związku Radzieckiego podczas
zimowej olimpiady w 1992 we FrancjiSCG - Serbia
i Montenegro - na tej samej olimpiadzie co wyżejJak widać, na tym wykresie pojawiły się reprezentacje państw z bardzo niewielką ilością zawodników, stąd trochę niewyważona statystyka. Niemniej ciekawe jest, że państwa bloku sowieckiego mają najlepszy stosunek medali do ilości zawodników.
max_Poland_age <- max(d1[d1$Team == "Poland",]$Age, na.rm = TRUE)
cat(max_Poland_age)
71
season_colors <- c("Winter" = "#636EFA", "Summer" = "#FFA15A")
season_names <- c("Winter" = "Zima", "Summer" = "Lato")
b <- ggplot(data=d1[d1$Team == "Poland",], aes(x=Sex, y=Height, color=Season)) +
geom_boxplot(alpha=0.9) +
ylim(140, 230) +
xlab("Płeć") +
ylab("Wzrost [cm]") +
ggtitle("Wzrost polskich zawodników") +
theme(text = element_text(family = "Courier New")) +
theme(axis.title.x = element_text(size=m),
axis.title.y = element_text(size=m),
axis.text.x = element_text(size=s),
axis.text.y = element_text(size=s),
legend.title = element_text(size=s),
legend.text = element_text(size=s),
legend.justification = c(0,0.5),
plot.title = element_text(colour="Black", size=l, family="Courier New")) +
scale_color_manual(values=season_colors, labels=season_names) +
scale_x_discrete(labels=c("F" = "Kobiety", "M" = "Mężczyźni")) +
labs(color='Sezon')
#b
Ten sam wykres, ale dla amerykańskich zawodników. Te dwa wykresy dają pewną wskazówkę dla korelacji wzrostu ze zwycięstwami, w zależności od sezonu - sportowcy z USA wygrywają przeważającą ilość medali i konsekwentnie w przypadku sezonu letniego są wyżsi, a zimowego - niżsi. Wyjątek stanowią kobiety uczestniczące w olimpiadzie zimowej. Kolejno zostaną sprawdzone korelacje.
Sprawdzenie korelacji odbędzie się na dwóch kolumnach. Zostaną wykorzystane atrybuty takie jak wiek, waga, wzrost, reprezentacja.
-Won - one-hot encoding - 0 lub
1, czy zawodnik zdobył złoty medal,
-Score- ordinal encoding - złoto:3,
srebro:2, brąz:1, brak
medalu:0
encode_gold <- function(medal) {
if (is.na(medal)) {return(0)}
else if (medal == "Gold") {return(1)}
else {{return(0)}}
}
cat(c(encode_gold('Gold'), encode_gold('Silver'), encode_gold(NA)))
1 0 0
encode_score <- function(medal) {
if (is.na(medal)) {return(0)}
else if (medal == "Gold") {return(3)}
else if (medal == "Silver") {return(2)}
else {{return(1)}}
}
cat(c(encode_gold('Gold'), encode_gold('Silver'), encode_gold(NA)))
1 0 0
d1 <- d1 %>%
mutate(Won = sapply(Medal, encode_gold)) %>%
mutate(Score = sapply(Medal, encode_score))
head(d1[68:69, 13:17]) %>%
kbl() %>%
kable_material(c("striped", "hover"))
| Sport | Event | Medal | Won | Score | |
|---|---|---|---|---|---|
| 68 | Alpine Skiing | Alpine Skiing Men’s Combined | Silver | 0 | 2 |
| 69 | Alpine Skiing | Alpine Skiing Men’s Downhill | NA | 0 | 0 |
quantitive_cols <- c("Age", "Height", "Weight", "Year", "Won", "Score")
round(cor(na.omit(d1[quantitive_cols])), digits = 2)
Age Height Weight Year Won Score
Age 1.00 0.14 0.21 0.09 0.01 0.02
Height 0.14 1.00 0.80 0.05 0.06 0.09
Weight 0.21 0.80 1.00 0.02 0.05 0.08
Year 0.09 0.05 0.02 1.00 -0.03 -0.04
Won 0.01 0.06 0.05 -0.03 1.00 0.80
Score 0.02 0.09 0.08 -0.04 0.80 1.00
Jak widać dla wszystkich danych korelacje są praktycznie nieznaczące, poza oczywistą korelacją waga-wzrost. Ponieważ w rzeczywistości mamy “filtr” odrzucający sportowców niespełniających wymagania uczestnictwa na najwyższym poziomie, większość sportowców na olimpiadzie będzie wykazywała te same cechy np. w koszykówce przeważająca większość zawodników będzie wysoka. Dlatego poprzez pętlę zostaną wyszukane dziedziny o istotnych korelacjach i jednocześnie różnorodnych cechach zawodników.
options(width = 110)
unique(d1$Sport)
[1] "Basketball" "Judo" "Football"
[4] "Tug-Of-War" "Speed Skating" "Cross Country Skiing"
[7] "Athletics" "Ice Hockey" "Swimming"
[10] "Badminton" "Sailing" "Biathlon"
[13] "Gymnastics" "Art Competitions" "Alpine Skiing"
[16] "Handball" "Weightlifting" "Wrestling"
[19] "Luge" "Water Polo" "Hockey"
[22] "Rowing" "Bobsleigh" "Fencing"
[25] "Equestrianism" "Shooting" "Boxing"
[28] "Taekwondo" "Cycling" "Diving"
[31] "Canoeing" "Tennis" "Modern Pentathlon"
[34] "Figure Skating" "Golf" "Softball"
[37] "Archery" "Volleyball" "Synchronized Swimming"
[40] "Table Tennis" "Nordic Combined" "Baseball"
[43] "Rhythmic Gymnastics" "Freestyle Skiing" "Rugby Sevens"
[46] "Trampolining" "Beach Volleyball" "Triathlon"
[49] "Ski Jumping" "Curling" "Snowboarding"
[52] "Rugby" "Short Track Speed Skating" "Skeleton"
[55] "Lacrosse" "Polo" "Cricket"
[58] "Racquets" "Motorboating" "Military Ski Patrol"
[61] "Croquet" "Jeu De Paume" "Roque"
[64] "Alpinism" "Basque Pelota" "Aeronautics"
head(d1[d1$Sport=="Basketball",][quantitive_cols],3)
Age Height Weight Year Won Score
1 24 180 80 1992 0 0
168 19 185 72 2008 0 0
251 31 NA NA 1952 0 0
cors <- round(cor(na.omit(d1[d1$Sport=="Basketball",][quantitive_cols])),
digits = 2
)
cors
Age Height Weight Year Won Score
Age 1.00 -0.02 0.04 0.31 0.01 -0.01
Height -0.02 1.00 0.87 0.09 0.05 0.06
Weight 0.04 0.87 1.00 0.09 0.05 0.05
Year 0.31 0.09 0.09 1.00 -0.07 -0.05
Won 0.01 0.05 0.05 -0.07 1.00 0.80
Score -0.01 0.06 0.05 -0.05 0.80 1.00
Pętla pozytywnych korelacji w dziedzinach olimpijskich (filtr powyżej 0.2) względem złota:
for(i in unique(d1$Sport)) {
subset <- na.omit(d1[d1$Sport==i,][quantitive_cols])
cors <- round(cor(subset), digits = 2)
win_cor <- cors[1:3,5] # korelacja dla Win
if (!anyNA(cors[1:3,5])) { # czy nie zawiera NA
if (max(win_cor) >= 0.2) {
print(i)
print(win_cor)
}
}
}
[1] "Softball"
Age Height Weight
-0.01 0.14 0.22
Pętla negatywnych korelacji w dziedzinach olimpijskich (filtr poniżej -0.2) względem złota:
for(i in unique(d1$Sport)) {
subset <- na.omit(d1[d1$Sport==i,][quantitive_cols])
cors <- round(cor(subset), digits = 2)
win_cor <- cors[1:3,5] # korelacja dla Win
if (!anyNA(cors[1:3,5])) { # czy nie zawiera NA
if (max(win_cor) <= -0.2) {
print(i)
print(win_cor)
}
}
}
[1] "Tug-Of-War"
Age Height Weight
-0.22 -0.21 -0.44
Okazuje się że w ogólnych dziedzinach (Sport) sportowych
korelacje zwycięstw do są również bardzo nieznaczne. Jedyne warte
wspomnienia to softball
oraz przeciąganie
liny, dziedziny, które pojawiły się na olimpiadach tylko pięć razy.
Poniżej sprawdzenie dla poszczególnych dyscyplin
(Event).
Pętla pozytywnych korelacji w dziedzinach olimpijskich (filtr powyżej 0.2 i 50 zawodników) względem złota:
for(i in unique(d1$Event)) {
subset <- na.omit(d1[d1$Event==i,][quantitive_cols])
cors <- round(cor(subset), digits = 2)
win_cor <- cors[1:3,5] # korelacja dla Win
if (!anyNA(cors[1:3,5])) { # czy nie zawiera NA
if (max(win_cor) > 0.25) { # korelacja +- 0.25
if (nrow(subset) >= 50) { # czy ilość zawodników jest sensowna
cat(nrow(subset), 'zawodników, ', i, '\n')
print(win_cor)
}
}
}
}
76 zawodników, Taekwondo Men's Featherweight
Age Height Weight
-0.11 0.12 0.41
82 zawodników, Cross Country Skiing Men's 10/10 kilometres Pursuit
Age Height Weight
0.10 0.26 0.25
136 zawodników, Cross Country Skiing Men's Team Sprint
Age Height Weight
0.05 0.13 0.26
82 zawodników, Shooting Women's Skeet
Age Height Weight
0.08 0.12 0.33
60 zawodników, Cycling Women's Individual Pursuit, 3,000 metres
Age Height Weight
0.01 0.23 0.36
74 zawodników, Swimming Men's 10 kilometres Open Water
Age Height Weight
0.02 0.34 0.26
51 zawodników, Shooting Women's Double Trap
Age Height Weight
-0.18 0.03 0.42
59 zawodników, Freestyle Skiing Women's Ski Cross
Age Height Weight
-0.06 0.31 0.16
Pętla negatywnych korelacji w dyscyplinach olimpijskich (filtr
poniżej -0.25 i powyżej i 50 zawodników) względem
złota:
for(i in unique(d1$Event)) {
subset <- na.omit(d1[d1$Event==i,][quantitive_cols])
cors <- round(cor(subset), digits = 2)
win_cor <- cors[1:3,5] # korelacja dla Win
if (!anyNA(cors[1:3,5])) { # czy nie zawiera NA
if (min(win_cor) < -0.25) { # korelacja +- 0.25
if (nrow(subset) >= 50) { # czy ilość zawodników jest sensowna
cat(nrow(subset), 'zawodników, ', i, '\n')
print(win_cor)
}
}
}
}
71 zawodników, Taekwondo Women's Heavyweight
Age Height Weight
-0.28 0.24 0.02
80 zawodników, Diving Women's Synchronized Springboard
Age Height Weight
0.00 0.03 -0.34
80 zawodników, Diving Men's Synchronized Platform
Age Height Weight
-0.19 -0.44 -0.46
80 zawodników, Diving Women's Synchronized Platform
Age Height Weight
-0.35 -0.19 -0.42
67 zawodników, Wrestling Women's Middleweight, Freestyle
Age Height Weight
-0.14 -0.06 -0.27
Z tych danych można podkreślić następujące zależności:
Poniżej to samo, ale sprawdzenie dla nowej kolumny
Score, a nie Win.
Pętla pozytywnych korelacji w dziedzinach olimpijskich (filtr powyżej
0.2) względem ustalonej punktacji Score:
for(i in unique(d1$Sport)) {
subset <- na.omit(d1[d1$Sport==i,][quantitive_cols])
cors <- round(cor(subset), digits = 2)
win_cor <- cors[1:3,6] # korelacja dla Win
if (!anyNA(cors[1:3,6])) { # czy nie zawiera NA
if (max(win_cor) >= 0.2) {
print(i)
print(win_cor)
}
}
}
[1] "Softball"
Age Height Weight
0.06 0.18 0.24
[1] "Synchronized Swimming"
Age Height Weight
0.23 0.09 0.08
[1] "Rhythmic Gymnastics"
Age Height Weight
0.00 0.24 0.05
Pętla negatywnych korelacji w dziedzinach olimpijskich (filtr poniżej
-0.2) względem ustalonej punktacji Score:
for(i in unique(d1$Sport)) {
subset <- na.omit(d1[d1$Sport==i,][quantitive_cols])
cors <- round(cor(subset), digits = 2)
win_cor <- cors[1:3,6] # korelacja dla Score
if (!anyNA(cors[1:3,6])) { # czy nie zawiera NA
if (max(win_cor) <= -0.2) {
print(i)
print(win_cor)
}
}
}
[1] "Tug-Of-War"
Age Height Weight
-0.24 -0.25 -0.52
Pętla negatywnych korelacji w dyscyplinach olimpijskich (filtr
poniżej -0.25 i powyżej i 50 zawodników) względem
Score:
for(i in unique(d1$Event)) {
subset <- na.omit(d1[d1$Event==i,][quantitive_cols])
cors <- round(cor(subset), digits = 2)
win_cor <- cors[1:3,6] # korelacja dla Win
if (!anyNA(cors[1:3,6])) { # czy nie zawiera NA
if (max(win_cor) > 0.25) { # korelacja +- 0.25
if (nrow(subset) >= 50) { # czy ilość zawodników jest sensowna
cat(nrow(subset), 'zawodników, ', i, '\n')
print(win_cor)
}
}
}
}
63 zawodników, Weightlifting Women's Super-Heavyweight
Age Height Weight
-0.11 0.28 0.21
77 zawodników, Taekwondo Men's Flyweight
Age Height Weight
-0.06 0.28 0.32
76 zawodników, Taekwondo Men's Featherweight
Age Height Weight
-0.08 0.11 0.33
78 zawodników, Taekwondo Men's Welterweight
Age Height Weight
-0.06 0.26 0.14
365 zawodników, Rhythmic Gymnastics Women's Group
Age Height Weight
0.02 0.29 0.08
437 zawodników, Figure Skating Mixed Pairs
Age Height Weight
0.27 0.05 0.03
206 zawodników, Rowing Women's Lightweight Double Sculls
Age Height Weight
0.17 0.27 0.13
54 zawodników, Gymnastics Women's Team Portable Apparatus
Age Height Weight
0.36 0.11 0.19
95 zawodników, Cross Country Skiing Women's 3 x 5 kilometres Relay
Age Height Weight
0.32 -0.11 -0.20
754 zawodników, Ice Hockey Women's Ice Hockey
Age Height Weight
0.13 0.23 0.31
206 zawodników, Curling Women's Curling
Age Height Weight
0.26 0.03 0.17
95 zawodników, Cycling Men's Madison
Age Height Weight
0.32 -0.14 -0.08
71 zawodników, Cross Country Skiing Women's 5/5 kilometres Pursuit
Age Height Weight
0.04 0.15 0.28
82 zawodników, Cross Country Skiing Men's 10/10 kilometres Pursuit
Age Height Weight
0.08 0.27 0.25
82 zawodników, Shooting Women's Skeet
Age Height Weight
0.08 0.14 0.35
69 zawodników, Snowboarding Women's Boardercross
Age Height Weight
0.10 0.26 0.09
74 zawodników, Swimming Men's 10 kilometres Open Water
Age Height Weight
0.11 0.34 0.20
51 zawodników, Shooting Women's Double Trap
Age Height Weight
-0.25 0.08 0.39
59 zawodników, Freestyle Skiing Women's Ski Cross
Age Height Weight
0.01 0.28 0.14
50 zawodników, Canoeing Men's Canadian Singles, 200 metres
Age Height Weight
0.20 0.22 0.40
Pętla negatywnych korelacji w dyscyplinach olimpijskich (filtr
poniżej -0.25 i powyżej i 50 zawodników) względem
Score:
for(i in unique(d1$Event)) {
subset <- na.omit(d1[d1$Event==i,][quantitive_cols])
cors <- round(cor(subset), digits = 2)
win_cor <- cors[1:3,6] # korelacja dla Win
if (!anyNA(cors[1:3,6])) { # czy nie zawiera NA
if (min(win_cor) < -0.25) { # korelacja +- 0.25
if (nrow(subset) >= 50) { # czy ilość zawodników jest sensowna
cat(nrow(subset), 'zawodników, ', i, '\n')
print(win_cor)
}
}
}
}
80 zawodników, Diving Women's Synchronized Springboard
Age Height Weight
0.14 0.03 -0.35
56 zawodników, Cross Country Skiing Men's 18 kilometres
Age Height Weight
-0.04 -0.17 -0.31
80 zawodników, Diving Men's Synchronized Platform
Age Height Weight
-0.24 -0.32 -0.38
60 zawodników, Fencing Women's Sabre, Team
Age Height Weight
-0.27 0.10 0.06
80 zawodników, Diving Women's Synchronized Platform
Age Height Weight
-0.32 -0.26 -0.37
129 zawodników, Short Track Speed Skating Women's 1,500 metres
Age Height Weight
-0.33 0.02 0.10
Wyniki przedstawiają się podobnie, w niektórych kategoriach
Win ma mniejsze wartości korelacji niż Score,
w innych większe. W przypadku pętli dla Score znaleziono
więcej kategorii, w których korelacje były znaczące. Ostatnią rzeczą
wartą zaznaczenia jest fakt, że wzrost ma najniższe korelacje spośród
wyżej wymienionych dyscyplin. Oznacza to, że różnice we wzroście są
najmniejsze lub najrzadsze, lub różnica we wzroście nie jest istotna w
większości dyscyplin.
Pakiet Shiny umożliwia tworzenie interaktywnych aplikacji i raportów, które w prosty sposób można udostępniać i otwierać np. w zwykłej przeglądarce internetowej.
Niestety, w celu uproszczenia udostępniania ninejszej strony, funkcjonalność pakietu Shiny zostanie przedstawiona w formie gifu. Prawdziwa aplikacja pod tym linkiem.
only_medals <- d1[!is.na(d1$Medal), ] # odfiltrowanie wierszy bez medali
ile_medali <- nrow(only_medals)
only_medals <- only_medals[only_medals$NOC %in% top_countries, ]
ile_po_filtrze <- nrow(only_medals)
cat("Ilość wierszy z medalami: ", ile_po_filtrze, ', ', round(ile_po_filtrze / ile_medali * 100, 2), '% medali zdobyło górne 25 państw.' )
Ilość wierszy z medalami: 32882 , 82.65 % medali zdobyło górne 25 państw.
# ograniczenie tylko do top 25 państw
d2 <- d1[d1$NOC %in% top_countries, ]
d2 <- d2[!is.na(only_medals$Medal), ]
# zgrupowanie
medal_yearly_counts <- d2 %>%
group_by(NOC, Year, Season, Medal) %>%
summarise(Count = n()) %>%
ungroup()
`summarise()` has grouped output by 'NOC', 'Year', 'Season'. You can override using the `.groups` argument.
head(medal_yearly_counts)
# A tibble: 6 × 5
NOC Year Season Medal Count
<chr> <int> <chr> <chr> <int>
1 AUS 1896 Summer Bronze 1
2 AUS 1896 Summer Gold 2
3 AUS 1896 Summer <NA> 2
4 AUS 1900 Summer Bronze 3
5 AUS 1900 Summer Gold 3
6 AUS 1904 Summer Bronze 1
Poniżej zostaną uwzględnienione 0.
expand.grid tworzy kartezjańską matrycę wszystkich
możliwych kombinacji
Ze względu na przesunięcie olimpiady zimowej, trzeba było specjalnie zapisać lata.
combinations_grid_summer <- expand.grid(
NOC = unique(d2$NOC),
Year = seq(1896, 2016, by = 4),
Season = c("Summer"),
Medal = c("Gold", "Silver", "Bronze")
)
combinations_grid_winter <- expand.grid(
NOC = unique(d2$NOC),
Year = c(seq(1924, 1992, by = 4), seq(1994, 2014, by = 4)), # przesunięcie odstępu w 1992 - 1994
Season = c("Winter"),
Medal = c("Gold", "Silver", "Bronze")
)
head(combinations_grid_winter)
NOC Year Season Medal
1 CHN 1924 Winter Gold
2 DEN 1924 Winter Gold
3 NED 1924 Winter Gold
4 USA 1924 Winter Gold
5 FIN 1924 Winter Gold
6 NOR 1924 Winter Gold
Teraz łączymy obie ramki danych. Bez podziału na Winter
i Summer, replace_na(list(Count = 0))
spowodowałoby, że wykresy byłyby bardzo nieczytelne od lat 80 - linia
skakałaby co 2 lata do 0.
combinations_grid <- bind_rows(combinations_grid_summer, combinations_grid_winter) # pionowe złączenie
complete_medal_counts <- combinations_grid %>%
left_join(medal_yearly_counts, by = c("NOC", "Year", "Season", "Medal")) %>%
replace_na(list(Count = 0))
head(complete_medal_counts)
NOC Year Season Medal Count
1 CHN 1896 Summer Gold 0
2 DEN 1896 Summer Gold 1
3 NED 1896 Summer Gold 0
4 USA 1896 Summer Gold 11
5 FIN 1896 Summer Gold 0
6 NOR 1896 Summer Gold 0
Poniżej kod dla utworzenia aplikacji Shiny.
### ============= UI ============= ###
ui <- fluidPage(
#Header
h1("Liczba medalistów z danego kraju na przestrzeni lat"),
fluidRow(
column(6,
selectInput(
inputId = "NOC",
label = "Wybierz kraj",
choices = sort(unique(complete_medal_counts$NOC)),
selected = "USA"
)
),
column(6,
radioButtons(
inputId = "Season",
label = "Wybierz sezon",
choices = unique(complete_medal_counts$Season),
selected = "Summer"
)
)
),
div(class = "plot-container",
plotOutput("plot")
)
)
### ============= SERVER ============= ###
server <- function(input, output, session) {
output$plot <- renderPlot({
years <- if (input$Season == "Summer") c(1896, 2016)
else c(1924, 2014)
ticks <- if (input$Season == "Summer") seq(1896, 2016, by = 4)
else c(seq(1924, 1992, by = 4), seq(1994, 2014, by = 4))
complete_medal_counts %>%
filter(NOC == input$NOC, Season == input$Season) %>%
ggplot(aes(x=Year, y=Count, color=Medal)) +
theme_minimal() + theme_light() +
geom_line(size=0.8) +
theme(text = element_text(family = "Courier New")) +
labs(color = "Medal:", y = "Ilość medali", x = "Rok", title = "") +
theme(
axis.title.x = element_text(size=m, margin = margin(t = 20)),
axis.title.y = element_text(size=m),
axis.text.x = element_text(size=s),
axis.text.y = element_text(size=s),
legend.title = element_text(size=s),
legend.text = element_text(size=s),
legend.justification = c(0,0.5),
plot.title = element_text(colour="Black", size=l, family="Courier New")) +
scale_x_continuous(limits = years, breaks = ticks, minor_breaks=NULL) +
scale_color_manual(values=medale_kolor, labels=medale_nazwy)
})
}
shinyApp(ui, server)
Na wykresach wyraźnie widoczne są bojkoty z olimpiady w Moskwie z 1980 roku i olimpiady w Los Angeles z 1984.
Widać również w jakich latach dane kraje istniały np.
RUS, USR czy GRD, czyli Rosja,
Związek Radziecki i NRD. Widoczne również są lata kiedy olimpiady nie
odbywały się: 1940-1944.
## Podsumowanie
W niniejszym projekcie sprawdzono: